COMMENT ⊗   VALID 00014 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001	   VALID 00012 PAGES
C00002 00002	BEGIN "TEST7"
C00004 00003	SUBR GLUEVV (ITG F1,F2)
C00006 00004	
C00007 00005	SUBR PARIM1(ITG F)		α PARIMETRIC PERIMETER
C00009 00006	
C00011 00007	α SUBR DPYFACE AND DPYSIZE AND DPYSLAB
C00014 00008	SUBR DPYSLAB (ITG SLAB)	α DISPLAY SLAB
C00016 00009	SUBR FFMATE(ITG F1,F2)
C00017 00010	SUBR INCRX		α INPUT CROSS SECTION LAMINA
C00019 00011	ITG SUBR FINDFACE(ITG FNEW,F1,FLG,SLAB)
C00021 00012	ITG SUBR FINDV (ITG F0,F1,I1)
C00023 00013	BOOLEAN SUBR CUTFACE (ITG SLAB)
C00025 00014	α MAIN EXECUTION
C00027 ENDMK
C⊗;
BEGIN "TEST7"
	
	REQUIRE "ABBREV[SYS,BGB]" SOURCE_FILE;
	REQUIRE "GEOMES.HDR" SOURCE_FILE;

	ITG W,B,B0,B1,B2,B3,N,CHR,FLG; STRING STR;
	ITG F,E,E0,V,V0;
	ITG I,LASTSLAB,CENTADE;

	EXTERNAL ITG UNIVERSE;

	SAFE ITG ARRAY DPYBUF[0:1000];
	SAFE REAL ARRAY WC[1:3];

	DEFINE NSLAB="200";
	SAFE ITG ARRAY HIFACE,LOFACE[0:NSLAB];
	SAFE ITG ARRAY UU,VV[0:100];


ITG SUBR COFACE (ITG V1,V2);
BEGIN "COFACE"
	ITG E,E0,F;
	E←E0←PED(V1);
	DO ⊂ 	F←FCCW(E,V1);
		IF LINKED(F,V2) THEN RETURN(F);
		E←ECCW(E,V1);
	⊃ UNTIL E=E0;
	OUTSTR(9&"WARNING - COFACE MISSING."&↓);
	RETURN(0);
END "COFACE";
SUBR GLUEVV (ITG F1,F2);
BEGIN "GLUEVV"
	ITG M,N,I,E,E0,V,U,F;

α PUT THE VERTICES INTO ARRAYS;
	E←E0←PED(F1);M←0;
	DO ⊂ V←VCCW(E,F1);VV[M←M+1]←V;E←ECCW(E,F1);⊃ UNTIL E=E0;
	E←E0←PED(F2);N←0;
	DO ⊂ V←VCCW(E,F2);UU[N←N+1]←V;E←ECCW(E,F2);⊃ UNTIL E=E0;

α GLUE F1 TO F2;
	V ← VV[1]; U←ALT(V);
	GLUEE(F1,V,F2,U);I←1;
	DO I←I+1 UNTIL U≠ALT(VV[I]);
	FOR I←I THRU M DO 
	⊂ V←VV[I];U←ALT(V);MKFE(U,F1,V); ⊃;

	FOR I←1 THRU N DO
	BEGIN
		U←UU[I]; V←ALT(U);
		IF LINKED(U,V) THEN CONTINUE;
		F←COFACE(U,V);
		IF F=0 THEN CONTINUE;
		MKFE(U,F,V);
	END;

	FOR I←1 THRU M DO
	BEGIN
		U←VV[I]; V←ALT(U);
		IF LINKED(U,V) THEN CONTINUE;
		F←COFACE(U,V);
		IF F=0 THEN CONTINUE;
		MKFE(U,F,V);
	END;
END "GLUEVV";

	ITG VCLOSEST;REAL ZCLOSEST;
SUBR VVMATE (ITG F1,F2);
BEGIN "VVMATE"
	ITG E0,E00,E1,E2,U,V;
	REAL Z,ZMIN;
		E1 ← E0 ← PED(F1);
	DO BEGIN
		V ← VCCW(E1,F1);
		E00 ← E2 ← PED(F2);
		ZMIN ← 999999;
	DO BEGIN
		U ← VCCW(E2,F2);
		Z ← DISTAN(U,V);
		IF Z < ZMIN THEN ⊂ ZMIN←Z; ALT→(U,V);
		IF Z < ZCLOSEST THEN ⊂ ZCLOSEST←Z; VCLOSEST←V;⊃;⊃;
		E2 ← ECCW(E2,F2);
	END UNTIL E2=E00;
		E1 ← ECCW(E1,F1);
	END UNTIL E1=E0;
END "VVMATE";
SUBR PARIM1(ITG F);		α PARIMETRIC PERIMETER;
BEGIN "PARIM1"
COMMENT ASSIGN PARAMETRIC VALUES 0 TO 1.0 IN XPP COUNTERCLOCKWISE;
COMMENT ASSIGN PARAMETRIC VALUES 0 TO 1.0 IN YPP CLOCKWISE;

	ITG E,E0,V0,V1,V2;REAL XXX;
	XXX ← 0;
	E ← E0 ← PED(F); V0←V2←VCCW(E,F);
	DO ⊂ V1←V2;E←ECCW(E,F);V2←VCCW(E,F);
		XXX←XPP(V2)←XXX+DISTAN(V1,V2);
	⊃ UNTIL V0=V2;
	E←E0←PED(F);
	DO ⊂ V1←VCCW(E,F);
	E←ECCW(E,F);ALT→(0,V1);
	XPP(V1)←XPP(V1)/XXX;		α COUNTER CLOCKWISE INCREASING;
	YPP(V1)←1.0 - XPP(V1);		α CLOCKWISE DECREASING;
	⊃ UNTIL E=E0;
	XPP(V0)←1.0;
	YPP(V0)←0.0;
END "PARIM1";
α -------------------------------------------------------------------;
SUBR PARIM2(ITG F1,F2);
BEGIN "PARIM2"
	ITG U0,U1,U2,V,E1,E2,E0;
	E0 ← E1 ← PED(F1);
	E1←ECCW(E1,F1);V←VCW(E1,F1);
	E2 ← PED(F2);
	U0 ← U1 ← VCCW(E2,F2);U2 ← VCW(E2,F2);
	ALT→(V,U0);ALT→(U0,V);
DO BEGIN
	V ← VCCW(E1,F1);E1 ← ECCW(E1,F1);
	WHILE XPP(V)>YPP(U2) ∧ U2≠U0 DO
	⊂ U1←U2;E2←ECW(E2,F2);U2←VCW(E2,F2);⊃;
	IF ABS(XPP(V)-YPP(U1))< ABS(XPP(V)-(IF U2≠U0 THEN YPP(U2) ELSE 1.0))
	THEN ALT→(U1,V) ELSE ALT→(U2,V);
END UNTIL E1=E0;
END "PARIM2";
COMMENT
SUBR DPYPM1(ITG F)%
BEGIN "DPYPM1"
	ITG E,E0,U,V,U0,V0%
	E ← E0 ← PED(F)%
	V0 ← VCCW(E,F)% U0 ← ALT(V0)%
	DO BEGIN
		V ← VCCW(E,F)%E←ECCW(E,F)%U←ALT(V)%
		AIVECT(1000*XPP(V)-500,000)%
		IF (U=U0)∧(0.5≤XPP(V)) THEN AVECT(500,200) ELSE
		AVECT (1000*YPP(U)-500,200)%
	END UNTIL E=E0%
END "DPYPM1"%

SUBR DPYPM2(ITG F)%
BEGIN "DPYPM2"
	ITG E,E0,U,V,U0,V0%
	E ← E0 ← PED(F)%
	V0 ← VCCW(E,F)% U0 ← ALT(V0)%
	DO BEGIN
		V ← VCCW(E,F)%E←ECCW(E,F)%U←ALT(V)%
		AIVECT(1000*YPP(V)-500,200)%
		IF (U=U0)∧(0.5≥YPP(V)) THEN AVECT(-500,000) ELSE
		AVECT (1000*XPP(U)-500,000)%
	END UNTIL E=E0%
END "DPYPM2"%
SUBR DPYPM3% 
BEGIN
	DPYSET(DPYBUF)%
	FOR I←0 STEP 10 UNTIL 100 DO
	⊂ AIVECT(I*10-500,0)%AVECT(I*10-500,-40)%DPYSST(CVS(I))%⊃%
	AIVECT(-500,0)%AVECT(+500,0)%
	AIVECT(-500,200)%AVECT(+500,200)%
	DPYPM1(F1)%DPYPM2(F2)%DPYOUT(1)%INCHRW%
END%;
α SUBR DPYFACE AND DPYSIZE AND DPYSLAB;

REAL SCALE,XMAX,XMIN,YMAX,YMIN,XORG,YORG;
SUBR DPYFACE (ITG FACE);
BEGIN "DPYFACE"
	ITG E,E0,U,V,I; REAL X0,Y0,X1,Y1;
	X0←Y0←I←0;
	E ← E0 ← PED(FACE);
	V ← VCW(E0,FACE);
	AIVECT(SCALE*(XWC(V)-XORG),SCALE*(YWC(V)-YORG));
	E ← E0 ← PED(FACE);
	V ← VCW(E0,FACE);
	DO BEGIN
		V ← VCCW(E,FACE); U←ALT(V); DPYBRT(6);
		X1←SCALE*(XWC(V)-XORG);	Y1←SCALE*(YWC(V)-YORG);
		AVECT(X1,Y1);	X0←X0+X1;Y0←Y0+Y1;
		DPYSST(CVS(I←I+1)&"'"&CVS(100*XPP(V))&"'"&CVS(100*YPP(V)));
		AIVECT(X1,Y1);
		IF U≠0 THEN ⊂ DPYBRT(2);
		AVECT(SCALE*(XWC(U)-XORG),SCALE*(YWC(U)-YORG));
		AIVECT(X1,Y1);⊃;
		E ← ECCW(E,FACE);
	END UNTIL E=E0;
	X0←X0/I;Y0←Y0/I;
	IF CENTADE≠0 THEN ⊂ AIVECT(X0,Y0);
	DPYSST(CVS(CENTADE));CENTADE←CENTADE+100;⊃;
	DPYBRT(2);
END "DPYFACE";
α -------------------------------------------------------------------;
SUBR DPYSIZE(ITG FACE);
BEGIN "DPYSIZE"
	ITG E,E0,V,I;I←0;
	E ← E0 ← PED(FACE);
	DO BEGIN
		V ← VCCW(E,FACE);ALT→(0,V);
		IF XMAX < XWC(V) THEN XMAX ← XWC(V);
		IF XMIN > XWC(V) THEN XMIN ← XWC(V);
		IF YMAX < YWC(V) THEN YMAX ← YWC(V);
		IF YMIN > YWC(V) THEN YMIN ← YWC(V);
		E ← ECCW(E,FACE);
	END UNTIL E=E0;
END "DPYSIZE";

SUBR DPYSLAB (ITG SLAB);	α DISPLAY SLAB;
BEGIN "DPYSLAB"
	ITG F,E,U,V;
	IF LOFACE[SLAB]LAND HIFACE[SLAB] THEN ELSE RETURN;

α MAXIMAL DISPLAY WINDOW;
	XMAX ← YMAX ← -999999;
	XMIN ← YMIN ← +999999;
	F ← LOFACE[SLAB]; WHILE F≠0 DO ⊂ DPYSIZE(F);F←ALT(F);⊃;
	F ← HIFACE[SLAB]; WHILE F≠0 DO ⊂ DPYSIZE(F);F←ALT(F);⊃;
	XORG ← 0.5*(XMAX+XMIN);
	YORG ← 0.5*(YMAX+YMIN);
	SCALE ← 800/((XMAX-XMIN)MAX(YMAX-YMIN));

α DISPLAY ALL THE FACES OF THE SLAB;
	DPYSET(DPYBUF);AIVECT(-450,-450);
	AVECT(+450,-450);AVECT(+450,+450);
	AVECT(-450,+450);AVECT(-450,-450);
	F ← LOFACE[SLAB]; CENTADE←(IF ALT(F)≠0 THEN 100 ELSE 0);
	 WHILE F≠0 DO ⊂ DPYFACE(F);F←ALT(F);⊃;
	F ← HIFACE[SLAB]; CENTADE←(IF ALT(F)≠0 THEN 100 ELSE 0);
	 WHILE F≠0 DO ⊂ DPYFACE(F);F←ALT(F);⊃;

α STATUS DISPLAY;
	AIVECT(300,400);DPYSST("SLAB "&CVS(SLAB));
	AIVECT(300,430);DPYSST("SCALE "&CVS(SCALE/800));
	DPYOUT(1);
END "DPYSLAB";
SUBR FFMATE(ITG F1,F2);
BEGIN "FFMATE"
	ITG U,V,E,I;
	
α FIND CLOSEST PAIR OF VERTICES;
	ZCLOSEST←999999;
	VVMATE(F2,F1);
	VVMATE(F1,F2);
	V←VCLOSEST; U←ALT(V);
	E←ECCW(F1,U);PED→(E,F1);
	E←ECCW(F2,V);PED→(E,F2);

α MATE REMAINING VERTICES;
	PARIM1(F1);		α COUNTER CLOCKWISE;
	PARIM1(F2);		α CLOCK WISE;
	PARIM2(F1,F2);
	PARIM2(F2,F1);
END "FFMATE";

SUBR INITIALIZATION;
BEGIN "INITIA"
	GEONIT;
	HIFACE[0]←LOFACE[0]←0;
	ARRBLT(HIFACE[1],HIFACE[0],NSLAB);
	ARRBLT(LOFACE[1],LOFACE[0],NSLAB);
	W ← SON(UNIVERSE);
END "INITIA";
SUBR INCRX;		α INPUT CROSS SECTION LAMINA;
BEGIN "INCRX"
	OPEN(2,"DSK",8,3,0,0,0,0);
	DO BEGIN
		OUTSTR(9&"CRX FILE = ");STR ←INCHWL;
		LOOKUP(2,STR&".CRX",FLG);
		IF STR="H" THEN
		ICAM("TMP.CAM[GEM,BGB]");
	END UNTIL ¬FLG;
WHILE TRUE DO
BEGIN "INPUT"
	ITG I,SLABHI,SLABLO,NCNT;
	ITG F1,F2,E;
	NCNT ← WORDIN(2); IF NCNT=0 THEN DONE;
	SLABLO ← WORDIN(2);
	SLABHI ← WORDIN(2);
	IF SLABHI>LASTSLAB THEN LASTSLAB←SLABHI;
	IF SLABLO>LASTSLAB THEN LASTSLAB←SLABLO;

α LAMINA BODY CREATION;
	B ← MKB(W);
	F1 ← MKF(B);			α F1 IS LOWER SURFACE OF LAMINA;
	V ← V0 ← MKV(B);

	FOR I←1 STEP 1 UNTIL NCNT DO
	BEGIN
		IF I≠1 THEN V←MKEV(F1,V);
		ARRYIN(2,WC[1],3);
		XWC(V) ← WC[1];
		YWC(V) ← WC[2];
		ZWC(V) ← WC[3];
	END;
		E ← MKFE(V0,F1,V);
		F2 ← NFACE(E);		α F2 IS UPPER SURFACE OF LAMINA;
α PLACE LAMINA FACES INTO SLAB ARRAYS;
	ALT→(HIFACE[SLABLO],F1);HIFACE[SLABLO]←F1;
	ALT→(LOFACE[SLABHI],F2);LOFACE[SLABHI]←F2;
END "INPUT";
END "INCRX";
ITG SUBR FINDFACE(ITG FNEW,F1,FLG,SLAB);
BEGIN "FINDFACE"
	ITG F2,CHR,I;

	F2 ← 0;
	WHILE TRUE DO 
BEGIN "FIND1"
	DPYSET(DPYBUF);
	CENTADE←0;
	DPYFACE(FNEW);			α TEMPLATE;
	DPYFACE(F1);			α CANDIDATE;
	DPYOUT(1);

α "YES" ANSWER: PULL F1 OUT OF THE LIST AND RETURN IT;
	CHR←INCHRW;
	IF "Y"=CHR ∨ "y"=CHR THEN 
BEGIN	
	I ← ALT(F1);
	IF F2=0 THEN 
		IF FLG THEN HIFACE[SLAB]←I ELSE LOFACE[SLAB]←I
		ELSE ALT→(I,F2);
	ALT→(0,F1);
	RETURN(F1);
END;

α "NO" ANSWER: ADVANCE DOWN FACE LIST OF THE SLAB;
	F2←F1;
	F1←ALT(F1);
	IF F1=0 THEN
	⊂ F1←(IF FLG THEN HIFACE[SLAB] ELSE LOFACE[SLAB]);F2←0;⊃;
END "FIND1"
END "FINDFACE";
ITG SUBR FINDV (ITG F0,F1,I1);
BEGIN "FINDV"
	ITG I,U,V,E,E0,EMIN,V1;
	REAL D,DMIN,X,Y,A,B,C,Q;
	I←200;
	WHILE I1>I ∧ ALT(F1)≠0 DO ⊂ F1←ALT(F1);I←I+100;⊃;
	I1 ← I1 MOD (I-100);

α GET THE I1'TH VERTEX OF F1;
	E ← E0 ← PED(F1);I←0;
	DO ⊂ V←VCCW(E,F1); E←ECCW(E,F1); I←I+1;
	IF I=I1 THEN V1←V;⊃ UNTIL E=E0;
	X ← XWC(V1); Y ←YWC(V1);

α GET THE EDGE OF F0 THAT IS CLOSEST TO V1;

	E ← E0 ← PED(F0); DMIN ← 9999999; EMIN ← 0;
DO BEGIN
	U ← PVT(E); V ← NVT(E);
	A ← YWC(U) - YWC(V);
	B ← XWC(V) - XWC(U);
	C ← XWC(U)*YWC(V) - XWC(V)*YWC(U);
	Q ← SQRT(A*A+B*B);
	D ← ABS((A*X + B*Y + C)/Q);
	IF D<DMIN ∧ DISTAN(V1,V)<Q ∧ DISTAN(V1,U)<Q THEN
	⊂ DMIN←D;EMIN←E;AA(E)←A/Q;BB(E)←B/Q;CC(E)←C/Q;⊃;
	E ← ECCW(E,F0);
END UNTIL E=E0;

	A←AA(EMIN);B←BB(EMIN);C←CC(EMIN);
	V ← ESPLIT(EMIN);D ← B*X - A*Y;
	XWC(V) ← B*D - A*C;
	YWC(V) ←-A*D - B*C;
	ZWC(V)←ZWC(U);
	RETURN(V);
	
END "FINDV";
BOOLEAN SUBR CUTFACE (ITG SLAB);
BEGIN "CUTFACE"
	ITG F0,F1,F2,V1,V2,E,E0,I,I1,I2,FLG,BRK;
	ITG ENEW,FNEW;
	STRING STR;

α GET SINGLETON FACE;
	F0 ← LOFACE[SLAB];
	F1 ← HIFACE[SLAB];
	FLG ← (ALT(F0)=0);	α FLG TRUE - LOFACE IS SINGLETON;
	IF FLG THEN ELSE F0↔F1;
	IF ALT(F0)≠0 THEN 
	⊂ OUTSTR("NO SINGLETON CUTFACE");INCHRW;RETURN(FALSE);⊃;

α ALLOW USER TO SPECIFY CUT VERTICES;

	OUTSTR(9&"CUTFACE V1 V2 = ");STR ← INCHWL;
	IF LENGTH(STR)=0 THEN RETURN(FALSE);
	IF STR="K" THEN ⊂ F1←FINDFACE(F0,F1,FLG,SLAB);
		E←PED(F1);I←CCW(E);KLBFEV(I);
		OUTSTR(9&"FACE KILL"&↓);RETURN(TRUE);⊃;

	I1 ← INTSCAN(STR,BRK);
	I2 ← INTSCAN(STR,BRK);

	E ← E0 ← PED(F0);I←0;
	DO ⊂ V←VCCW(E,F0); E←ECCW(E,F0); I←I+1;
	IF I=I1 THEN V1←V;IF I=I2 THEN V2←V;⊃ UNTIL E=E0;
	IF I1>100 THEN V1←FINDV(F0,F1,I1);
	IF I2>100 THEN V2←FINDV(F0,F1,I2);

α MAKE THE NEW FACE;
	ENEW ← MKFE(V1,F0,V2);
	FNEW ← NFACE(ENEW);

α FIND MATE;
	F1 ← FINDFACE(FNEW,F1,FLG,SLAB);

α STORE THE FACES OF THE NEW SLAB;
	I ← LASTSLAB ← LASTSLAB+1;
	IF FLG THEN ELSE F1↔FNEW;	α FORCE FNEW TO BE THE LOFACE;
	LOFACE[I] ← FNEW;
	HIFACE[I] ← F1;
	RETURN(TRUE);
END "CUTFACE";
α MAIN EXECUTION;
BEGIN "MAIN"
	ITG I,B,W,B0;
	INITIALIZATION;
	INCRX;

	OUTSTR(9&CVS(LASTSLAB)&" SLABS READ IN"&↓);
	FOR I←1 STEP 1 UNTIL LASTSLAB DO
BEGIN "PASS1"
	IF (LOFACE[I]≠0)∧(HIFACE[I]≠0) ∧
	(ALT(LOFACE[I])≠0 ∨ ALT(HIFACE[I])≠0) THEN
	⊂ DPYSLAB(I);IF CUTFACE(I) THEN I←I-1; ⊃;
END "PASS1";
	OUTSTR(" END OF PASS1 "&↓);
	FOR I←1 STEP 1 UNTIL LASTSLAB DO
BEGIN "PASS2"
	IF    (LOFACE[I] ≠0)∧    (HIFACE[I] ≠0) ∧
	   ALT(LOFACE[I])=0 ∧ ALT(HIFACE[I])=0 THEN ⊂
	FFMATE(LOFACE[I],HIFACE[I]);
	GLUEVV(LOFACE[I],HIFACE[I]);⊃;
END "PASS2";

	GEODPY;
	W ← SON(UNIVERSE);
	B0 ← CCW(W);
	B ← CCW(B0);I←1;
	WHILE B≠W DO ⊂ BATT(B,B0);I←I+1;B←CCW(B);⊃;
	IF I=1 THEN OUTSTR("	ONE BODY."&↓) ELSE
	OUTSTR(9&CVS(I)&" BODIES"&↓);
	OGEM("TMP",B0);

END "MAIN"
END "TEST7"; BGB 1 FEBRUARY 1974.